PC Pro 2005 June (DVD)/DPPRO0605DVD.iso/Install/program files/Borland/BDS/3.0/Demos/Delphi.Net/CLR/Chat/SocketManager.pas

Pascal/Delphi Source File | 2004-10-22 | 12.9 KB | 424 lines

unit SocketManager;
{*******************************************************************************
  TCP/IP Chat Demo
  Written by David Clegg, [e-mail].
*******************************************************************************}

interface

uses
  System.Net.Sockets, System.Threading, System.Collections;

type
  TByteArray = array[0..255] of Byte;

  TDataReceivedEvent = procedure(Sender: TObject; const pData: string) of object;
  TErrorEvent = procedure(Sender: TObject; E: Exception) of object;
  TSocketEvent = procedure(Sender: TObject; pSocket: Socket);

  TStateObject = class
  strict private
    FWorkSocket: Socket;
    FBufferSize: integer;
    //FBuffer: TByteArray;
  public
    //The buffer must be a public field otherwise it will not be populated when
    //being passed to methods such as Socket.BeginReceive
    Buffer: TByteArray;
    //property Buffer: TByteArray read FBuffer write FBuffer;
    property WorkSocket: Socket read FWorkSocket write FWorkSocket;
    property BufferSize: Integer read FBufferSize write FBufferSize;
    constructor Create(pWorkSocket: Socket);
  end;

  TSocketManager = class
  private
    FClientSocket: Socket;
    FServerSocket: Socket;
    FOnClientConnected: TSocketEvent;
    FOnClientDisconnected: TSocketEvent;
    FStopEvent: ManualResetEvent;
    FConnectEvent: ManualResetEvent;
    FTransmitLock: ReaderWriterLock;
    FReceiveLock: ReaderWriterLock;
    FTransmitQueue: Queue;
    FOnDataReceived: TDataReceivedEvent;
    FOnSendError: TErrorEvent;
    FOnReceiveError: TErrorEvent;
    FOnListenError: TErrorEvent;
    FOnConnectError: TErrorEvent;
    FListening: boolean;
    FConnected: boolean;
    procedure SendThreadEntryPoint(pState: TObject);
    procedure ReceiveThreadEntryPoint(pState: TObject);
    procedure ListenThreadEntryPoint(pState: TObject);
    procedure SendCallback(pAsyncResult: IAsyncResult);
    procedure ReceiveCallback(pAsyncResult: IAsyncResult);
    procedure AcceptCallback(pAsyncResult: IAsyncResult);
    procedure InitResetEvents;
  public
    property OnDataReceived: TDataReceivedEvent read FOnDataReceived write FOnDataReceived;
    property OnSendError: TErrorEvent read FOnSendError write FOnSendError;
    property OnReceiveError: TErrorEvent read FOnReceiveError write FOnReceiveError;
    property OnListenError: TErrorEvent read FOnListenError write FOnListenError;
    property OnConnectError: TErrorEvent read FOnConnectError write FOnConnectError;
    property OnClientConnected: TSocketEvent read FOnClientConnected write FOnClientConnected;
    property OnClientDisconnected: TSocketEvent read FOnClientDisconnected write FOnClientDisconnected;
    property ClientSocket: Socket read FClientSocket;
    property ServerSocket: Socket read FServerSocket;
    property Connected: boolean read FConnected write FConnected;
    property Listening: boolean read FListening write FListening;
    procedure Listen;
    procedure StopListening;
    procedure Connect(const pAddress: string; const pPort: integer);
    procedure Disconnect;
    procedure SendText(const pText: string);
    constructor Create;
  end;

implementation

uses
  System.Net, System.Text, SysUtils, System.Windows.Forms;

{ TStateObject }
constructor TStateObject.Create(pWorkSocket: Socket);
begin
  inherited Create;
  FBufferSize := 256;
  FWorkSocket := pWorkSocket;
end;

{ TSocketManager }
constructor TSocketManager.Create;
begin
  inherited Create;
  InitResetEvents;
end;

/// <summary>
/// Create the objects required to control the threads.
/// </summary>
procedure TSocketManager.InitResetEvents;
begin
  //Create Reset Event instances
  FStopEvent := ManualResetEvent.Create(False);
  FConnectEvent := ManualResetEvent.Create(False);

  //Create ReaderWriterLock instances
  FTransmitLock := ReaderWriterLock.Create;
  FReceiveLock := ReaderWriterLock.Create;

  //Create Transmit and Receive Queue instances
  FTransmitQueue := Queue.Create;
end;

/// <summary>
/// Listen for client connections on the server socket.
/// </summary>
procedure TSocketManager.Listen;
var
  lEndPoint: IPEndPoint;
  lHostEntry: IPHostEntry;
begin
  try
    FStopEvent.Reset;
    lHostEntry := Dns.Resolve(Dns.GetHostName);
    if Length(lHostEntry.AddressList) <> 0 then
    begin
      lEndPoint := IPEndPoint.Create(lHostEntry.AddressList[0], 1024);
      FServerSocket := Socket.Create(AddressFamily.InterNetwork, SocketType.Stream, ProtocolType.TCP);
      FServerSocket.Bind(lEndPoint);

      //Pool the Listen thread entry point
      ThreadPool.QueueUserWorkItem(ListenThreadEntryPoint);
      FListening := True;
    end;
  except
    on E: Exception do
      if Assigned(FOnListenError) then
        FOnListenError(Self, E);
  end;
end;

/// <summary>
/// Signal to the server worker threads that they should stop.
/// </summary>
procedure TSocketManager.StopListening;
begin
  FStopEvent.&Set;
  FListening := False;
end;

/// <summary>
/// Connect to the TCP/IP server.
/// </summary>
/// <param name="pAddress">Address of TCP/IP Server to connect to.</param>
/// <param name="pPort">Port of TCP/IP Server to connect to.</param>
procedure TSocketManager.Connect(const pAddress: string; const pPort: integer);
var
  lEndPoint: IPEndPoint;
  lHostEntry: IPHostEntry;
begin
  try
    FStopEvent.Reset;
    lHostEntry := Dns.Resolve(pAddress);
    if Length(lHostEntry.AddressList) <> 0 then
    begin
      lEndPoint := IPEndPoint.Create(lHostEntry.AddressList[0], pPort);
      FClientSocket := Socket.Create(lEndPoint.AddressFamily, SocketType.Stream, ProtocolType.TCP);
      //No need to connect asynchronously
      FClientSocket.Connect(lEndPoint);

      //Pool the send and seceive thread entry points
      ThreadPool.QueueUserWorkItem(ReceiveThreadEntryPoint);
      ThreadPool.QueueUserWorkItem(SendThreadEntryPoint);
      FConnected := True;
    end;
  except on e: Exception do
    FOnConnectError(Self, e);
  end;
end;

/// <summary>
/// Send text through the socket connection.
/// </summary>
/// <param name="pText">The text to send.</param>
procedure TSocketManager.SendText(const pText: string);
begin
  if Assigned(FClientSocket) and FClientSocket.Connected then
  begin
    FTransmitLock.AcquireWriterLock(-1);
    try
      FTransmitQueue.Enqueue(pText);
    finally
      FTransmitLock.ReleaseWriterLock;
    end;
  end;
end;

/// <summary>
/// Disconnect the client socket, and signal the worker threads to stop.
/// </summary>
procedure TSocketManager.Disconnect;
begin
  //signal the threads to end
    FStopEvent.&Set;
  if Assigned(FClientSocket) then
  begin
    //Disable sending and receiving on the socket
    FClientSocket.Shutdown(SocketShutdown.Both);
    //Close the socket
    FClientSocket.Close;
    FreeAndNil(FClientSocket);
  end;
  FConnected := False;
end;

//***** TCP/IP Asynchronous Callback Methods *****

/// <summary>
/// Callback method called by the asynchronous BeginSend method.
/// </summary>
procedure TSocketManager.SendCallback(pAsyncResult: IAsyncResult);
var
  lSocket: Socket;
begin
  lSocket := Socket(pAsyncResult.AsyncState);
  try
    lSocket.EndSend(pAsyncResult);
  except
    on e: Exception do
      if Assigned(FOnSendError) then
        FOnSendError(lSocket, e);
  end;
end;

/// <summary>
/// Callback method called by the asynchronous BeginReceive method.
/// </summary>
procedure TSocketManager.ReceiveCallback(pAsyncResult: IAsyncResult);
var
  lBytesRead: Integer;
  lClient: Socket;
  lState: TStateObject;
begin
  lClient := nil;
  try
    if FStopEvent.WaitOne(10, true) then
      exit;

    lState := TStateObject(pAsyncResult.AsyncState);
    lClient := lState.WorkSocket;
    if Assigned(lClient) and lClient.Connected then
    begin
      //We are still connected
      lBytesRead := lClient.EndReceive(pAsyncResult);
      if (lBytesRead > 0) then
      begin
        if Assigned(FOnDataReceived) then
          //Notify that data has been received
          FOnDataReceived(lClient, Encoding.ASCII.GetString(lState.Buffer, 0, lBytesRead));
        //Keep listening for more data
        lClient.BeginReceive(lState.Buffer, 0, lState.BufferSize, SocketFlags.None, ReceiveCallback, lState);
      end
      else
      begin
        FClientSocket.Shutdown(SocketShutdown.Both);
        FClientSocket.Close;
        FOnClientDisconnected(Self, FClientSocket);
      end;
    end;
  except
    on e: Exception do
      if Assigned(FOnReceiveError) then
        FOnReceiveError(lClient, e);
  end;
end;

/// <summary>
/// Callback method called by the asynchronous BeginAccept method.
/// </summary>
procedure TSocketManager.AcceptCallback(pAsyncResult: IAsyncResult);
var
  lListener: Socket;
begin
  FConnectEvent.&Set;

  //Get the socket that handles the client request.
  lListener := Socket(pAsyncResult.AsyncState);
  FClientSocket := lListener.EndAccept(pAsyncResult);
  if Assigned(FOnClientConnected) then
    FOnClientConnected(FServerSocket, FClientSocket);

  //Pool the send and seceive thread entry points
  ThreadPool.QueueUserWorkItem(ReceiveThreadEntryPoint);
  ThreadPool.QueueUserWorkItem(SendThreadEntryPoint);
  FServerSocket.BeginAccept(AcceptCallback, FServerSocket);
end;

//***** TCP/IP Thread Entry Point Methods *****

/// <summary>
/// Send Thread entry point.
/// </summary>
procedure TSocketManager.SendThreadEntryPoint(pState: TObject);
var
  lWorkQueue: Queue;
  i: integer;
  lStateObject: TStateObject;
  lBuffer: TBytes;
  lAsyncResult: IAsyncResult;
begin
  try
    lWorkQueue := Queue.Create;

    while True do
    begin
      if FStopEvent.WaitOne(10, true) then
        break
      else if Assigned(FClientSocket) and FClientSocket.Connected then
      begin
        //We are still connected, so process the send queue
        FTransmitLock.AcquireWriterLock(-1);
        try
          try
            for i := 0 to FTransmitQueue.Count -1 do
              lWorkQueue.Enqueue(FTransmitQueue.DeQueue);
          except
            on e: Exception do
              if Assigned(FOnSendError) then
                FOnSendError(FClientSocket, e);
          end;
        finally
          FTransmitLock.ReleaseWriterLock;
        end;

        //Loop through the work queue and send all messages
        for i := 0 to lWorkQueue.Count -1 do
        begin
          //Create the State object and buffer the string
          lStateObject := TStateObject.Create(FClientSocket);
          lBuffer := Encoding.ASCII.GetBytes(lWorkQueue.DeQueue.ToString);

          //Send the contents of the buffer
          lAsyncResult := FClientSocket.BeginSend(lBuffer, 0, Length(lBuffer),
            SocketFlags.None, SendCallback, FClientSocket);
        end;
      end;
    end;
  except on e: Exception do
    if Assigned(FOnSendError) then
      FOnSendError(FClientSocket, e);
  end;
end;

/// <summary>
/// Receive Thread entry point.
/// </summary>
procedure TSocketManager.ReceiveThreadEntryPoint(pState: TObject);
var
  lAsyncResult: IAsyncResult;
  lStateObject: TStateObject;
begin
    try
    while True do
    begin
      if Assigned(FClientSocket) then
        if FClientSocket.Connected then
        try
          //Start the receive operation
          lStateObject := TStateObject.Create(FClientSocket);
          lAsyncResult := FClientSocket.BeginReceive(lStateObject.Buffer,
                  0, lStateObject.BufferSize, SocketFlags.None, ReceiveCallback, lStateObject);
          if FStopEvent.WaitOne(10, true) then
            //Stop event was signalled, so break out of the loop
            break;
        except on
          e: Exception do
            if Assigned(FOnReceiveError) then
              FOnReceiveError(FClientSocket, e);
        end
        else
        begin
          if Assigned(FOnClientDisconnected) then
            FOnClientDisconnected(FServerSocket, FClientSocket);
        end;
    end;
  except
    on e: Exception do
      if Assigned(FOnReceiveError) then
        FOnReceiveError(FClientSocket, e);
  end;
end;

/// <summary>
/// Listen thread entry point.
/// </summary>
procedure TSocketManager.ListenThreadEntryPoint(pState: TObject);
begin
  try
    while True do
    try
      //Set the event to nonsignaled state.
      FConnectEvent.Reset;
      //Listen, allowing a queue of 1 connection
      FServerSocket.Listen(1);
      FServerSocket.BeginAccept(AcceptCallback, FServerSocket);

      if FStopEvent.WaitOne(10, true) then
        //stop event was signalled, so break out of the loop
        break;
    except on e: Exception do
      if Assigned(FOnListenError) then
        FOnListenError(FServerSocket, e);
    end;
    FServerSocket.Close;
  except on e: Exception do
    if Assigned(FOnListenError) then
      FOnListenError(FServerSocket, e);
  end;
end;

end.